perm filename MAKLAP[MAC,LSP] blob
sn#451452 filedate 1979-06-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002
C00004 00003
C00019 00004
C00023 00005
C00026 00006
C00040 00007
C00044 00008
C00046 00009
C00049 00010
C00052 00011
C00056 00012
C00058 ENDMK
C⊗;
;;; MAKLAP -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ***** (File parser for COMPLR) *****************
;;; **************************************************************
;;; ** (C) Copyright 1979 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
(DEFUN CMPTIME-EVAL MACRO (X) (AND (EVAL (CADR X)) (EVAL (CADDR X))))
(CMPTIME-EVAL 'T
`(SETQ MAKLAPVERNO ',(cond ((caddr (truename infile)))
('/21))))
(EVAL-WHEN (COMPILE)
(AND (OR (NOT (GET 'COMPDECLARE 'MACRO))
(NOT (GET 'FREEAC)))
(LOAD (LIST (COND ((STATUS FEATURE ITS) '(DSK COMLAP))
((STATUS FEATURE DEC20) '(DSK MACLISP))
((STATUS FEATURE SAIL) '(DSK (MAC LSP)))
((STATUS FEATURE D10) '(LISP MACLISP))
('T (BREAK WHERE-IS-CDMACS) '(* *)))
'CDMACS
'FASL))))
(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|mk|))
(COMMENT FILE-TRANSDUCERS)
(DEFUN CMP1 () ;Transduce a file compileing those sexps which try to define functions
((LAMBDA (SYMBOLS READTABLE OBARRAY MSGFILES)
(PROG (ERRFL X NAME NAMEFORM DECLARATION-FLAGCONVERSION-TABLE FL FORM PRATTSTACK PXHFL)
(SETQ DECLARATION-FLAGCONVERSION-TABLE
'((*FEXPR . FEXPR) (*EXPR . EXPR) (*LEXPR .EXPR)))
(AND RECOMPL
(MAP '(LAMBDA (L) (AND (NOT (EQ (CAR L) (SETQ X (INTERN (CAR L)))))
(RPLACA L X)))
RECOMPL))
A (COND (PRATTSTACK (SETQ FORM (CAR PRATTSTACK) PRATTSTACK (CDR PRATTSTACK)))
((EQ GOFOO (SETQ FORM (COND (READ (FUNCALL READ GOFOO))
('T (READ GOFOO)))))
(AND FASLPUSH LAPLL (TERFASL))
(RETURN GOFOO)))
(AND CHOMPHOOK (MAPC '(LAMBDA (F) (FUNCALL F FORM)) CHOMPHOOK))
B (COND ((ATOM FORM) (GO ICF))
((EQ (CAR FORM) 'DEFPROP)
(SETQ X (CDDR FORM) FL (CADR X) NAME (CADR FORM))
(COND ((OR (NULL (CDR X)) (CDDR X) (NOT (SYMBOLP NAME)))
(GO GH))
((OR (ATOM (CAR X)) (NOT (EQ (CAAR X) 'LAMBDA)))
(GO ICF))
((EQ FL 'MACRO)
(CMP1-MACRO-ENLIVEN (CONS 'DEFUN
(CONS NAME
(CONS 'MACRO
(CDAR X))))
() ))
((ASSQ FL COMPILATION-FLAGCONVERSION-TABLE)
(SETQ FORM (CONS 'DEFUN
(CONS NAME
(CONS FL
(CDAR X)))))
(GO B))
((AND (SETQ X (GETL NAME '(*EXPR *FEXPR *LEXPR)))
(NOT (EQ FL (CDR (ASSQ (CAR X) DECLARATION-FLAGCONVERSION-TABLE)))))
(WRNTYP NAME)
(PUTPROP NAME 'T (CAAR (ASSOCR FL DECLARATION-FLAGCONVERSION-TABLE)))))
(GO ICF))
((EQ (CAR FORM) 'DEFUN)
(AND (OR (NULL (CDR FORM)) (NULL (CDDR FORM)) (NULL (CDDDR FORM)))
(GO GH))
(COND ((SYMBOLP (SETQ NAME (CADR FORM))) (SETQ NAMEFORM () ))
((ATOM NAME) (GO GH))
('T (SETQ NAME (CAR (SETQ NAMEFORM NAME)))
(AND (COND ((NOT (SYMBOLP NAME)))
((NULL (CDR NAMEFORM)))
((NOT (SYMBOLP (CADR NAMEFORM))))
((NULL (CDDR NAMEFORM)) ())
((NOT (SYMBOLP (CADDR NAMEFORM)))))
(GO GH))))
(AND (NOT (MEMQ (SETQ FL (CADDR FORM)) '(FEXPR EXPR MACRO)))
(SETQ FORM (CONS 'DEFUN
(CONS (OR NAMEFORM NAME)
(CONS (SETQ FL 'EXPR)
(CDDR FORM))))))
(AND (NULL (CDDDDR FORM)) (GO GH))
(COND ((ATOM (SETQ X (NTH 3 FORM))))
((OR (MEMQ '&OPTIONAL X) (MEMQ '&REST X) (MEMQ '&AUX X))
(SETQ FORM (CONS 'DEFUN& (CDR FORM)))
(GO B)))
(AND NAMEFORM
(EQ (CADR NAMEFORM) 'MACRO)
(CMP1-MACRO-ENLIVEN (CONS 'DEFUN
(CONS NAME
(CONS 'MACRO
(CDDDR FORM))))
() ))
(COND ((AND (NULL NAMEFORM) (EQ FL 'MACRO))
(CMP1-MACRO-ENLIVEN FORM 'T))
((AND RECOMPL (NOT (MEMQ NAME RECOMPL))))
((ASSQ FL COMPILATION-FLAGCONVERSION-TABLE)
(SETQ UNDFUNS (DELQ NAME UNDFUNS))
(SETQ LAP-INSIGNIF () )
(SETQ PXHFL 'T)
(COND ((NULL NAMEFORM) (SETQ NAMEFORM NAME))
((NOT (ATOM NAMEFORM))
(COND ((NULL (CDDR NAMEFORM))
(SETQ NAME (PNAMECONC (CAR NAMEFORM)
'/
(CADR NAMEFORM)))
(ICOUTPUT (LIST 'DEFPROP
(CAR NAMEFORM)
NAME
(CADR NAMEFORM)))
(SETQ NAMEFORM NAME))
('T (SETQ PXHFL () ))) ))
(AND EXPR-HASH
PXHFL
(ICOUTPUT (LIST 'DEFPROP
NAME
(SXHASH (CONS 'LAMBDA (CDDDR FORM)))
'EXPR-HASH)))
((LAMBDA (COMPILER-STATE ↑W ↑R)
(COMPILE NAMEFORM
FL
(CONS 'LAMBDA (CDDDR FORM))
()
() )
(COND (TTYNOTES
(SETQ ↑W (SETQ ↑R () ))
(INDENT-TO-INSTACK 0)
(PRIN1 NAMEFORM)
(PRINC '| Compiled|)))
(SETQ ↑W (SETQ ↑R 'T))
(COND (FASLPUSH (AND LAPLL (TERFASL)))
('T (TYO 12.)))
(COND (TTYNOTES
(SETQ ↑W (SETQ ↑R () ))
(COND (FASLPUSH (PRINC '| and assembled |))
('T (TYO 32.))))))
'COMPILE ↑W ↑R)
(GO A))
('T (GO ICF) ))
(AND RECOMPL (GO A)))
((COND ((AND (EQ (CAR FORM) 'ARRAY) (SETQ NAME (CADR FORM)))
(MEMQ (SETQ FL (CADDR FORM)) '(T () FIXNUM FLONUM OBARRAY)))
((AND (EQ (CAR FORM) '*ARRAY)
(P1EQQTE (CADR FORM))
(SETQ NAME (CADADR FORM))
(COND ((MEMQ (SETQ FL (CADDR FORM)) '(T () )))
((P1EQQTE FL)
(MEMQ (SETQ FL (CADR FL))
'(T () FIXNUM FLONUM OBARRAY READTABLE)))))))
(AND (NOT (MEMQ FL '(FIXNUM FLONUM))) (SETQ FL 'NOTYPE))
(SETQ X (DO ((L (CDDDR FORM) (CDR L)) (Z) (T1))
((NULL L) (LIST (CONS NAME (NREVERSE Z))))
(COND ((OR (FIXP (SETQ T1 (CAR L)))
(AND (P1EQQTE T1) (FIXP (SETQ T1 (CADR T1)))))
(PUSH T1 Z))
('T (RETURN (LIST NAME (LENGTH (CDDDR FORM)))) ))))
(COND ((GET NAME '*ARRAY)
(PUTPROP NAME () '*ARRAY) ;To prevent spurious re-declared msgs
((LAMBDA (T1) (AND (COND (T1 (PUTPROP NAME () 'NUMFUN)
(COND ((CADR T1) (NOT (EQ (CADR T1) FL)))
((NOT (EQ FL 'NOTYPE)))))
((NOT (EQ FL 'NOTYPE))))
(PUTPROP NAME '(() () ) 'NUMFUN)))
(GET NAME 'NUMFUN))))
(AR*1 (CONS FL X))
(SETQ LAP-INSIGNIF () )
(COUTPUT FORM))
((MEMQ (CAR FORM) '(DECLARE EVAL-WHEN))
(SETQ X INFILE)
(LET ((COMPILER-STATE COMPILER-STATE) LOADP EVALP (L FORM))
(AND (COND ((EQ (CAR FORM) 'DECLARE)
(SETQ EVALP 'T COMPILER-STATE 'DECLARE)
'T)
((PROG2 (SETQ L (CDR L))
(MEMQ COMPILER-STATE '(MAKLAP COMPILE DECLARE)))
(SETQ LOADP (MEMQ 'LOAD (CAR L))
EVALP (MEMQ 'COMPILE (CAR L)))
(OR EVALP LOADP))
;This allows for COMPILER-STATE to be () and TOPLEVEL
((SETQ EVALP (MEMQ 'EVAL (CAR L)))))
(PROGN (AND EVALP
(ATOM (ERRSET (MAPC 'EVAL (CDR L)) 'T))
(PDERR FORM |Evaluation loses due to some error|))
(AND LOADP
(SETQ PRATTSTACK
(APPEND (CDR L) PRATTSTACK))) )))
(COND ((NOT (EQ INFILE X))
(MAPC '(LAMBDA (DATA)
(AND (FILEP DATA)
(SETQ X (CAR (STATUS FILEM DATA)))
(EQ (CAR X) 'IN) (EQ (CADR X) 'ASCII)
(NOT (EQ (CADDR X) 'TTY))
(EOFFN DATA 'COEFN)))
(CONS INFILE INSTACK))))
(GO A))
((COND (#(SAILP) (MEMQ (CAR FORM) '(INCLUDE REQUIRE)))
((EQ (CAR FORM) 'INCLUDE)))
(SETQ X INSTACK FL () )
(AND (NOT (PROBEF (COND ((CDDR FORM) (CDR FORM))
((CADR FORM)))))
(DBARF (CDR FORM) |File for INCLUDEsion is missing|))
(ERRSET (SETQ FL (EVAL FORM)) 'T) ;Try to "include" file
(COND (TTYNOTES
(PROG (↑W ↑R)
(INDENT-TO-INSTACK 1)
(PRINC (COND (FL '|;Including file |)
('T '|;Failure to include file |)))
(PRIN1 (TRUENAME FL)))))
(COND (FL (EOFFN FL 'COEFN))
('T (AND (NOT (EQ X INSTACK)) (INPUSH -1))
(PDERR FORM |File not included|)))
(GO A))
((EQ (CAR FORM) 'CGOL) (CGOL))
((EQ (CAR FORM) 'LAP)
(CMP-LAPFUN (CDR FORM))
(COND ((AND RECOMPL (NOT (MEMQ (CADR FORM) RECOMPL)))
(ZAP2NIL FORM () ))
(FASLPUSH (AND LAPLL (TERFASL))
(FASLIFY FORM 'LAP)) ;Hack the LAP code
('T (ZAP2NIL FORM 'T)
(AND TTYNOTES ((LAMBDA (↑R ↑W)
(PRINT (CADR FORM))
(PRINC '|LAP code zapped |))
() () )))) )
((AND (EQ (CAR FORM) 'LAP-A-LIST)
(NOT (ATOM (CADR FORM)))
(EQ (CAADR FORM) 'QUOTE)
(SETQ X (CADADR FORM))
(NOT (ATOM (CAR X)))
(EQ (CAAR X) 'LAP))
(CMP-LAPFUN (CDAR X))
(COND ((OR (NOT FASLPUSH)
(AND RECOMPL (NOT (MEMQ (CADAR X) RECOMPL))))
(ICOUTPUT FORM))
('T (AND LAPLL (TERFASL))
(FASLIFY X 'LIST))))
((AND (EQ (CAR FORM) 'PROGN) ;(PROGN 'COMPILE . . .)
(NOT (ATOM (CADR FORM)))
(EQ (CAADR FORM) 'QUOTE)
(EQ (CADADR FORM) 'COMPILE))
(SETQ PRATTSTACK (APPEND (CDDR FORM) PRATTSTACK))
(GO A))
((AND (AND FORM (ATOM (CAR FORM)))
(PROG2 (AND (GET (CAR FORM) 'AUTOLOAD)
(NOT (GETL (CAR FORM) '(SUBR FSUBR LSUBR EXPR FEXPR MACRO)))
(OR (NOT (GET (CAR FORM) 'FUNTYP-INFO))
(NOT (EQ (CAR (GET (CAR FORM) 'FUNTYP-INFO)) 'MACRO)))
(FUNCALL AUTOLOAD (CONS (CAR FORM) (GET (CAR FORM) 'AUTOLOAD))))
'T)
(GET (CAR FORM) 'MACRO))
(SETQ FL () )
(COND ((OR (NULL (ERRSET (SETQ FORM (MACROEXPAND FORM)
FL 'T )
'T))
(NULL FL))
(PDERR FORM |Error during top level MACRO expansion|)
(GO A)))
(GO B) ) ;Apply macro property and try again
((NOT RECOMPL)
(SETQ LAP-INSIGNIF () )
(COUTPUT FORM)
(AND (EQ (CAR FORM) 'COMMENT) LAPLL (TERFASL)) ))
(AND (NOT FASLPUSH) (ICOUTPUT GOFOO))
(GO A)
ICF (SETQ LAP-INSIGNIF () )
(ICOUTPUT FORM)
(AND (NOT FASLPUSH) (PROG2 (ICOUTPUT NULFU) (ICOUTPUT GOFOO)))
(GO A)
GH (DBARF FORM |Illegal DEFUN format| 4 4) ))
SYMBOLS CREADTABLE COBARRAY CMSGFILES))
(DEFUN CMP1-MACRO-ENLIVEN (FORM FL)
;;; Expects input to be of form "(DEFUN name MACRO (var) . body)"
((LAMBDA (NAME)
(COND ((NULL MACROS))
((NOT FL))
('T (ICOUTPUT FORM)
(SETQ LAP-INSIGNIF () ) ))
(COND ((LAND '(EXPR FEXPR SUBR FSUBR LSUBR AUTOLOAD)
(STATUS SYSTEM NAME))
(OR (GET NAME 'SKIP-WARNING)(WARN NAME
|being redefined as a MACRO by user file - /
definition is pushed on MACROLIST|))
(PUSH (CONS NAME (CONS 'LAMBDA (CDDDR FORM))) MACROLIST))
('T (EVAL FORM))))
(CADR FORM)))
(DEFUN TERFASL ()
(FASLIFY (NREVERSE (PROG2 () LAPLL (SETQ LAPLL () )))
'LIST))
(DEFUN COEFN (FIL EOFVAL) ;Standard EOFFN for main
(AND (EQ FIL INFILE) (INPUSH -1)) ; input source file
(COND (TTYNOTES ;Pop file off stack
(PROG (↑W ↑R)
(INDENT-TO-INSTACK 0)
(PRINC '|;End Of File |)
(PRIN1 (NAMESTRING (TRUENAME FIL))))))
(AND (FILEP FIL) (CLOSE FIL)) ;Close file. If more is on
(COND (INSTACK 'T) ; stack, keep reading;
('T EOFVAL))) ; otherwise we have a real EOF
(DEFUN CHMP2 (L FILE) ;"CHOMP"ing also to a file
(AND (NOT (GET 'FASL-START 'SUBR))
(DBARF () |Cant CHOMP to file without FASLOAD|))
(FASL-START FILE () )
(LAP-FILE-MSG (CONS '|##IN-CORE-FUNCTIONS##| L)
(CONS TYO UFFIL))
(MAPC '(LAMBDA (X) (CHMP1 X) (FASLIFY LAPLL 'LIST))
L)
(FASL-CLOSEOUT FILE '((|##IN-CORE-FUNCTIONS##|)) FILE))
(DEFUN CMP-LAPFUN (X)
((LAMBDA (TYPE PROP)
(SETQ LAP-INSIGNIF () )
(SETQ UNDFUNS (DELQ (CAR X) UNDFUNS))
(COND ((OR (NULL TYPE) (AND PROP (NOT (EQ (CAR PROP) TYPE))))
(WRNTYP (CAR X)))
('T (PUTPROP (CAR X) TYPE 'T))))
(CDR (ASSQ (CADR X) '((SUBR . *EXPR) (FSUBR . *FEXPR) (LSUBR . *LEXPR))))
(GETL (CAR X) '(*EXPR *FEXPR *LEXPR))))
(DEFUN INDENT-TO-INSTACK (II) ;TERPRI and indent proportional to length of INSTACK
(TERPRI)
(DO ((N (- (LENGTH INSTACK) II 2) (1- N)))
((MINUSP N))
(PRINC '| |)))
(DEFUN PRINT-LINEND (X FLAG)
(COND (FLAG (PRIN1 X)) ((PRINC X)))
(PRINC '|/) |)
(TERPRI)
'T)
(DEFUN LAP-FILE-MSG (REALI L)
#(LET ((TERPRI 'T) (OUTFILES L) TEM)
(SETQ TEM (STATUS DATE))
(SETQ ↑W (SETQ ↑R 'T))
(COND (FASLPUSH (UNFASL-MSG REALI))
('T (TERPRI)
(PRINC '|'(THIS IS THE LAP FOR |)
(PRINT-LINEND REALI 'T)))
(PRINC '|'(COMPILED BY LISP COMPILER //|)
(PRINC COMPLRVERNO)
(PRINC '| COMAUX //|) (PRINC COMAUXVERNO)
(PRINC '| PHAS1 //|) (PRINC PHAS1VERNO)
(PRINC '| MAKLAP //|) (PRINC MAKLAPVERNO)
(PRINC '| INITIA //|) (PRINC INITIAVERNO)
(PRINT-LINEND '|)| () )
(COND (TEM #(LET ((BASE 10.) (*NOPOINT 'T) (APM 'AM) (II 0))
(TERPRI)
(PRINC '|;COMPILED ON |)
(COND ((AND #(ITSP) (SETQ APM (STATUS DOW)))
(PRINC APM)
(SETQ APM 'AM)
(PRINC '|, |)))
(PRINC (CAR #(NCDR '(JANUARY FEBRUARY MARCH APRIL MAY
JUNE JULY AUGUST SEPTEMBER
OCTOBER NOVEMBER DECEMBER)
(1- (CADR TEM)))))
(PRINC '| |)
(PRINC (CADDR TEM))
(PRINC '|, |)
(PRINC (+ 1900. (CAR TEM)))
(COND ((SETQ TEM (STATUS DAYTIME))
(PRINC '|, AT |)
(SETQ II (CAR TEM))
(COND ((ZEROP II)
(AND (= (CADR TEM) 0)
(SETQ APM 'MIDNITE))
(PRINC '/12))
((= II 12.)
(SETQ APM (COND ((= (CADR TEM) 0)
'NOON)
('PM)))
(PRINC '/12))
('T (AND (> II 12.)
(SETQ APM 'PM II (- II 12.)))
(PRINC II)))
(COND ((< (CADR TEM) 10.) (PRINC '/:/0))
('T (PRINC '/:)))
(PRINC (CADR TEM))
(PRINC '/ )
(PRINC APM)))
(TERPRI))))
(SETQ LAP-INSIGNIF 'T)))
(DEFUN MAKLAP FEXPR (L)
(COND (FILESCLOSEP (SETQ CMSGFILES () ) (GC) (SETQ FILESCLOSEP () )))
#(LET ((EOC-EVAL EOC-EVAL) (RECOMPL RECOMPL) (LINEL 120.) (READ READ) (*LOC 0)
(OCMSGFILES CMSGFILES) (IMOSAR IMOSAR) (INFILE 'T) (FILOC 0) (LITLOC 0))
(PROG (BRKC LINE INMLS ONMLS JCLP REALI FSLNL DEFAULT-NAMELIST DEF2N TOPFN
SWITCHLIST OPNDP FASLERR COMPILER-STATE LAP-INSIGNIF CURRENTFNSYMS
CURRENTFN MAINSYMPDL UNFASLSIGNIF ENTRYNAMES ALLATOMS FBARP START-LINE
SYMPDL ATOMINDEX DDTSYMP SYMBOLSP LITERALS NOC F-NOC TEM OUTFILES
INSTACK UFFIL CMSGFILES FASLPUSH ↑W ↑Q ↑R )
B0 (SETQ UNDFUNS () COMPILER-STATE 'MAKLAP FSLNL ()
REALI () FASLPUSH () LAP-INSIGNIF 'T FASLERR ()
CMSGFILES OCMSGFILES F-NOC () )
B (SETQ ↑W (SETQ ↑R (SETQ ↑Q () )))
(SETQ SWITCHLIST () INMLS () )
(SETQ DEFAULT-NAMELIST (CONS (LIST 'DSK (STATUS UDIR))
(CONS '* (COND (#(ITSP) '(>) )
(#(SAILP) '(|←←←|) )
('(LSP) )))))
(COND ((NULL L) ;Normal case
(TERPRI)
(PRINC '|←| TYO)
(AND (NUMBERP (SETQ TEM (READLINE TYI 0))) (GO B))
(SETQ LINE (EXPLODEN TEM)))
((AND (CAR L) (ATOM (CAR L))) ;Compilation begun from JCL
(SETQ JCLP 'T LINE L L () )
(SSTATUS FEATURE NOLDMSG))
('T (AND (NOT DISOWNED) (TERPRI)) ;JPG's case
(SETQ DEF2N (FASL-LAP-P))
(COND ((CDR L)
(SETQ ONMLS (LIST (MERGEF (MERGEF (CAR L) DEF2N)
DEFAULT-NAMELIST))
INMLS (MAPCAR 'NAMELIST (CDR L)))
(MAKLAP-MERGEF
INMLS
(COND ((EQ MAKLAP-DEFAULTF-STYLE 'MIDAS)
(MERGEF (CDR DEFAULT-NAMELIST)
(CAR (LAST ONMLS))))
(DEFAULT-NAMELIST))))
((SETQ INMLS (LIST (MERGEF (CAR L) DEFAULT-NAMELIST))
ONMLS (LIST (MERGEF DEF2N (CAR INMLS))))))
(GO A)))
(AND (= (CAR LINE) 40.) (PUSH 32. LINE))
;position START-LINE for switch parsing
(AND (NULL (DO ( (L LINE (CDR L)) )
((NULL (CDR L)) () )
(COND ((OR (= (CADR L) 17.) (= (CADR L) 47.))
(POP L))
((= (CADR L) 40.)
(RETURN (SETQ START-LINE L))))))
(GO A0))
(DO ( (OBARRAY SOBARRAY) (PARITY 'T)
(L (CDR START-LINE) (CDR L)) )
((NULL L))
(COND ((= (CAR L) 41.) ;right parens
(RPLACD START-LINE (CDR L)) ;cuts out chars for switches
(RETURN () ))
((NOT (> (CAR L) 32.))) ;ignore space and tab
((OR (= (CAR L) 73.) (= (CAR L) 105.)) ;Upper and lower case I
(PUSH
(COND ((= (CADR L) 91.) ;Aha!, a "["
(POP L)
(DO ((Z))
((OR (NULL L) (= (CAR L) 93.)) ; so look for "]"
(MAKNAM (NREVERSE Z)))
(PUSH (POP L) Z)))
('(T)))
INITIALIZE)
(SETQ PARITY 'T))
((= (CAR L) 45.) (SETQ PARITY () )) ;- means set to ()
((SETQ TEM (ASSQ (ASCII (COND ((> (CAR L) 96.) (- (CAR L) 32.))
((CAR L))))
SWITCHTABLE))
(PUSH (LIST (CADR TEM) PARITY) SWITCHLIST)
(SETQ PARITY 'T ))))
(AND (NULL INITIALIZE) (NULL SWITCHLIST) (GO IIS))
; Create file names from input line characters and do filename defaulting
A0 (SETQ DEF2N (FASL-LAP-P))
(AND (OR (NULL LINE) (= (CAR LINE) 95.) (= (CAR LINE) 44.))
(GO IIS))
(SETQ START-LINE LINE BRKC () ) ;scan to "←" or end
(DO ( (L LINE (CDR L)) )
( (OR (NULL (CDR L)) (= (CADR L) 95.))
(SETQ BRKC (CADR L) LINE (CDDR L))
(RPLACD L () )))
(COND ((NULL LINE)
(SETQ INMLS (RDSYL START-LINE DEFAULT-NAMELIST)
ONMLS (LIST (MERGEF DEF2N (CAR INMLS)))))
('T (SETQ ONMLS (RDSYL START-LINE (CONS (CAR DEFAULT-NAMELIST)
DEF2N)))
(AND (OR (NULL BRKC)
(NULL LINE)
(= (CAR LINE) 95.)
(= (CAR LINE) 44.))
(GO IIS))
(SETQ START-LINE LINE BRKC () ) ;scan to "←" or end
(DO ( (L LINE (CDR L)) )
( (OR (NULL (CDR L)) (= (CADR L) 95.))
(SETQ BRKC (CADR L) LINE (CDDR L))
(RPLACD L () )))
(AND (OR BRKC LINE) (GO IIS))
(SETQ INMLS (RDSYL START-LINE
(COND ((EQ MAKLAP-DEFAULTF-STYLE 'MIDAS)
(MERGEF (CDR DEFAULT-NAMELIST)
(CAR (LAST ONMLS))))
(DEFAULT-NAMELIST)) ))
(AND (EQ MAKLAP-DEFAULTF-STYLE 'MIDAS)
(EQ (CADAR ONMLS) '*)
(MAKLAP-MERGEF ONMLS (CAR INMLS)))))
(AND (OR (OR (NULL INMLS) (EQ (CADAR INMLS) '*))
(OR (NULL ONMLS) (EQ (CADAR ONMLS) '*)))
(GO IIS))
A (SETQ FASLPUSH (AND (NOT ASSEMBLE) NOLAP))
(SETQ FILESCLOSEP 'T)
(SETQ REALI (ERRSET (EOPEN (COND (#(SAILP) (UGREAT1 (CAR INMLS)))
((CAR INMLS)))
'IN)
() ))
(COND (REALI
(SETQ REALI (TRUENAME (INPUSH (CAR REALI))))
((LAMBDA (BASE *NOPOINT)
(SETQ GENPREFIX
(NCONC (COND ((OR #(SAILP) #(DEC10P))
(NCONC (LIST '/[)
(EXPLODEC (CAR (CADAR REALI)))
(LIST '/,)
(EXPLODEC (CADR (CADAR REALI)))
(LIST '/])))
(#(DEC20P)
(NCONC (LIST '/<)
(EXPLODEC (CADAR REALI))
(LIST '/>)))
('T (NCONC (EXPLODEC (CADAR REALI)) (LIST '/;))))
(EXPLODEC (CADR REALI))
(LIST (COND (#(ITSP) '/ ) ('/.)))
(EXPLODEC (CADDR REALI))
'(/←))))
10. 'T))
((AND L (NOT JCLP)) (RETURN () ))
('T (PRIN1 (CAR INMLS))
(PRINC '| File Not Found - MAKLAP|)
(GO B0)))
(COND ((AND JCLP (OR TTYNOTES YESWARNTTY)) () )
((OR DISOWNED JCLP) (GIVUPTTY)))
(COND (ASSEMBLE (FASL-A-FILE (CAR ONMLS) INMLS)
(AND NOLAP
(NOT (MEMBER (CAR ONMLS) INMLS))
(MAPC 'DELETEF INMLS))
(GO ENDUP)))
(COND (FASLPUSH (FASL-START (SETQ FSLNL (CAR ONMLS)) () ))
('T (POP ONMLS TEM)
(AND FASL (SETQ FSLNL TEM))
(LAPOP TEM)))
(AND (OR YESWARNTTY TTYNOTES)
(NOT (MEMQ TYO CMSGFILES))
(PUSH TYO CMSGFILES))
(SETQ OPNDP 'T)
D2 (COND ((NULL (CAR INMLS)) (WARN () |Phooey on JPG - MAKLAP|) (GO ENDUP)))
(SETQ NOC () )
(COND (OPNDP (SETQ OPNDP ())
(AND #(SAILP) (EOPEN INFILE 'IN))
(SETQ REALI (LIST REALI)))
('T (APPLY 'EREAD (CAR INMLS))
(PUSH (STATUS UREAD) REALI)))
(AND TTYNOTES
(PROG (↑R ↑W)
(TERPRI)
(PRINC '|Compilation begun on |)
(PRIN1 (CAR REALI))
(PRINC '| |)))
(LAP-FILE-MSG (CAR REALI) (COND (FASLPUSH UFFIL) ;Sets LAP-INSIGNIF to T
('T (CONS LAPOF UFFIL)))) ; as well as ↑R ↑W
(SETQ ↑Q 'T)
C (SETQ TOPFN ()
TEM (COND ((OR (NOT (FILEP INFILE))
(NULL (STATUS FILEMODE INFILE)))
CLPROGN)
((ERRSET (CMP1) 'T))))
(COND ((ATOM TEM)
(AND (EQ TEM 'FASLAP) (SETQ FASLERR 'T))
(COND (FASLPUSH)
('T (PRINC '| () | LAPOF)))
(AND TOPFN (SETQ NOC (CONS TOPFN NOC))) ;NOC accumulates function names that cop out
(COND ((NULL TEM)
#(WARN (LIST (CONS 'TOPFN TOPFN)
(CONS
'FILEPOS
(COND ((OR (NOT (FILEP INFILE))
(NULL (STATUS FILEMODE INFILE)))
'CLOSED)
((FILEPOS INFILE)))))
|Lisp Error during file compilation|)
(MSOUT-BRK () SOBARRAY SREADTABLE 'LISP-ERROR)
(GO C))
((EQ TEM GOFOO)
#(DBARF INFILE |EOF encountered during READ,
possibly misbalanced paresn?|))
('T (GO C))) ))
(SETQ TOPFN () )
(COND (NOC
(SETQ NOC (NREVERSE NOC))
(SETQ F-NOC (NCONC F-NOC (APPEND NOC () )))
#(WARN NOC |- Failed to compile|)))
(COND ((SETQ INMLS (CDR INMLS)) (GO D2)))
(COND (UNDFUNS #(WARN UNDFUNS |have been used but remain undefined in this file|)))
(SETQ REALI (NREVERSE REALI))
(AND TTYNOTES
(PROG (↑Q ↑R ↑W)
(TERPRI)
(PRINT (COND ((CDR REALI) REALI) ((CAR REALI))))
(PRINC '| Finished compilation|)
(COND (F-NOC (PRINC '|, but |)
(PRIN1 F-NOC)
(PRINC '| Failed to compile|)))
(PRINC '| |) ))
(COND (FASLERR
#(WARN () |/
**ERROR** FASL file aborted due to errors during FASLAP|)
(AND FASLPUSH (FASL-CLOSEOUT () () FSLNL)))
(FASLPUSH
(FASL-CLOSEOUT (CAR ONMLS)
(AND (NOT LAP-INSIGNIF) REALI)
FSLNL))
('T (LAPCL (CAR ONMLS))
(SETQ ONMLS (NREVERSE ONMLS))
(AND FSLNL (FASL-A-FILE FSLNL ONMLS))))
(AND (FILEP INFILE) (CLOSE INFILE))
(SETQ FILESCLOSEP () )
ENDUP (MAPC 'EVAL EOC-EVAL)
(AND (OR JCLP DISOWNED) (QUIT))
EXIT (AND L (RETURN () )) (GO B0)
IIS (PRINC '|INCORRECT COMMAND SYNTAX - MAKLAP|) (GO EXIT) )))
(DEFUN FASL-LAP-P ()
(AND INITIALIZE
(MAPC '(LAMBDA (X) (COND ((SYMBOLP X) (ELOAD X))
('T (INITIALIZE))))
INITIALIZE))
(MAPC 'SETQ SWITCHLIST)
(COND ((OR ASSEMBLE NOLAP FASL) '(* FASL))
('(* LAP))))
;Returns "LAP" iff this run is compile-only
;;; HOW TO DISOWN FROM A ↑B BREAK
(DEFUN DISOWN FEXPR (X) (SETQ DISOWNED 'T) (GIVUPTTY) (THROW X BREAK))
(DEFUN GIVUPTTY ()
(SETQ GAG-ERRBREAKS (SETQ ↑W 'T) TTYNOTES () YESWARNTTY () )
(AND (MEMQ TYO CMSGFILES)
(SETQ CMSGFILES (DELQ TYO (APPEND CMSGFILES () ))))
(AND (MEMQ TYO MSGFILES)
(SETQ MSGFILES (DELQ TYO (APPEND MSGFILES () ))))
(AND (STATUS TTY)
(STATUS HACTRN)
(VALRET (COND (DISOWNED '|:PROCED :DISOWN |) ('|:PROCED |)))))
(DEFUN SPLITFILE FEXPR (L)
(COND ((OR ASSEMBLE (NULL L) (CDR L))
(PUSH 'SPLITFILE L)
(COND (ASSEMBLE (PDERR L |SPLITFILE not yet implemented for A switch|))
((PDERR L |Lose lose - SPLITFILE|)))))
(SETQ L (LIST (CAAR ONMLS) (CAR L) (CADDAR ONMLS)))
(COND (FASLPUSH
(FASL-CLOSEOUT (CAR ONMLS)
(COND (LAP-INSIGNIF (POP ONMLS) () ) ;() FLUSHES NULL FASL FILE
('T (TERFASL) (CAR ONMLS)))
() ) ;Dont close unfasl file
(FASL-START L 'T) ; but do continue it
(UNFASL-MSG L)
(PUSH L ONMLS))
('T (LAPCL (CAR ONMLS)) ;SETS LAP-INSIGNIF TO T
(COND (LAP-INSIGNIF (DELETEF (CAR ONMLS)) (POP ONMLS))) ;AS WELL AS ↑R ↑W
(LAP-FILE-MSG (LAPOP L) (LIST LAPOF)))))
(DEFUN LAPCL (F)
(SETQ CMSGFILES (DELQ LAPOF CMSGFILES))
(SETQ OUTFILES (DELQ LAPOF OUTFILES))
(COND (F (AND (PROBEF F) (DELETEF F))
(AND (FILEP LAPOF) (RENAMEF LAPOF F))))
(AND (FILEP LAPOF) (CLOSE LAPOF))
F)
(DEFUN LAPOP (F)
(SETQ F (MERGEF '((DSK *) * LAP) F))
(SETQ LAPOF (EOPEN (MERGEF '(* ←LAP←) F) 'OUT))
(LINEL LAPOF 80.)
(PUSH LAPOF OUTFILES)
(PUSH LAPOF CMSGFILES)
(PUSH F ONMLS)
F)
(DEFUN RDSYL (L DF)
(PROG (LL BRAKP ANS CH)
(SETQ DF (MERGEF DF '((* *) * *)))
AA (SETQ LL (SETQ BRAKP () ))
A (SETQ CH (OR (CAR L) 95.))
(COND ((OR (= CH 47.) (= CH 17.)) ;"/" and "⊃"
(POP L)
(SETQ CH (CAR L)))
((AND (= CH 91.) (NOT #(ITSP))) ;"["
(SETQ BRAKP 'T))
((AND (= CH 93.) (NOT #(ITSP))) (SETQ BRAKP () )) ;"]"
((OR (= CH 40.) (= CH 41.)) (RETURN () )) ;Cant have parens here
((= CH 44.) ;Comma
(COND ((NOT BRAKP)
(POP L)
(GO RET))))
((= CH 95.) (GO RET)))
(PUSH CH LL)
(POP L)
(GO A)
RET (SETQ DF (MERGEF (NAMELIST (MAKNAM (NREVERSE LL))) DF))
(SETQ ANS (NCONC ANS (LIST DF)))
(AND (= CH 44.) (GO AA))
(RETURN ANS) ))
(DEFUN MAKLAP-MERGEF (LL DFNL)
(MAP '(LAMBDA (L) (RPLACA L (SETQ DFNL (MERGEF (CAR L) DFNL))))
LL)
() )
;;;(DEFUN FNCP (II) ;File-Name-Character-Predicate
;;; (OR (LESSP 59. II 95.) ;Gets <, ?, @, A-Z, [, \, ], ↑
;;; (LESSP 47. II 58.) ;Gets 0 - 9
;;; (LESSP 32. II 40.) ;Gets ! to ' (Tops of 1 to 4)
;;; (= II 43.) (= II 45.) ;Gets + and -
;;; (COND ((NOT #(ITSP)) () )
;;; ((OR (= II 42.) ;Gets *
;;; (= II 46.)))))) ;Gets .
(DEFUN ZAP2NIL (DATA FL)
(DECLARE (SPECIAL LINEL) (FIXNUM LINEL CHAR))
(PROG (CHAR FLAG N LINEL ↑R ↑W)
(SETQ LINEL (LINEL LAPOF))
(SETQ ↑R (SETQ ↑W 'T))
(COND (FL (TERPRI)
(LINEL LAPOF 0.)
(PRINT DATA)))
A (SETQ CHAR (ZTYI))
(COND ((= CHAR 13.) ;<carriage-return>
(AND (= 10. (TYIPEEK)) (TYI)) ;flush any following line-feed
(SETQ FLAG () ))
(FLAG)
((= CHAR 47.) (AND FL (TYO CHAR)) (SETQ CHAR (ZTYI))) ;<slash>
((= CHAR 59.) (SETQ FLAG 'T)) ;<semi-colon>
((= CHAR 40.) ;<open-parens>
(AND (ZEROP N)
(= (TYIPEEK) 41.) ;<close-parens>
(PROG2 (AND FL (PRINC '|() |) (TERPRI) (TYO 12.))
(GO XIT)))
(SETQ N (1+ N)))
((= CHAR 41.) (SETQ N (1- N))) ;<close-parens>
((AND (OR (= CHAR 78.) (= CHAR 110.)) (ZEROP N)) ; |N|, |n|
(AND FL (TYO CHAR))
(COND ((OR (= (SETQ CHAR (ZTYI)) 73.) (= CHAR 105.)) ; |I|, |i|
(AND FL (TYO CHAR))
(COND ((OR (= (SETQ CHAR (ZTYI)) 76.) ; |L|, |l|
(= CHAR 108.))
(AND FL (TYO CHAR))
(COND ((= (SETQ CHAR (ZTYI)) 32.)
(AND FL (PRINC '| |) (TERPRI) (TYO 12.))
(GO XIT)))))))))
(AND FL (TYO CHAR))
(GO A)
XIT (LINEL LAPOF LINEL) ))
(DEFUN ZTYI ()
((LAMBDA (CHAR)
(AND (OR (= CHAR -1)
(AND #(ITSP)
(= CHAR 3)
(OR (NOT (FILEP INFILE))
(AND (MEMQ 'FILEPOS (CDR (STATUS FILEM INFILE)))
(> (FILEPOS INFILE) (- (LENGTHF INFILE) 6))) )))
(SETQ TOPFN (CADR DATA)) ;set up name of losing LAP function
(DBARF '? |End-Of-File in middle of LAP code - check for misbalanced parens|))
CHAR)
(TYI -1)))
;;; FASL-A-FILE SHOULD ONLY BE CALLED BY MAKLAP, FOR MAKLAP BINDS LOTS OF LOSING SPECIAL VARIABLES
;;; HOWEVER, FASLTRY TRYES TO SIMULATE THIS CALL FOR A TEST CASE
(DEFUN FASL-A-FILE (TARGETFILE SOURCEFILES)
((LAMBDA (BASE IBASE OBARRAY READTABLE MSDIR EOF WINP REALSFS TOPFN)
(ERRSET
(PROGN
(GCTWA T)
(FASL-START TARGETFILE () )
(DO SFS SOURCEFILES (CDR SFS) (NULL SFS)
(APPLY 'EREAD (CAR SFS)) ;OPEN LAP SOURCE FILE
(PUSH (STATUS UREAD) REALSFS)
(UNFASL-MSG (CAR REALSFS))
(SETQ ↑Q T)
(DO Y
(READ EOF)
(AND ↑Q (READ EOF))
(OR (NULL ↑Q) (EQ Y EOF))
(FASLIFY Y ())))
(SETQ WINP T)))
(GCTWA ())
(COND ((OR (NULL WINP) FBARP) ;IF SOME ERROR OCCURRED,
(SETQ TOPFN CURRENTFN)
(PDERR (LIST *LOC FILOC) |Faslization aborted after so many words| )
(AND ↑Q (DO () ((EQ EOF (READ EOF))))) ;CLEAN OUT TO END OF FILE
(SETQ REALSFS ()) ;IDENTIFY LOSER TO FASL-CLOSEOUT
(ERR 'FASLAP)))
(FASL-CLOSEOUT TARGETFILE REALSFS TARGETFILE)
(AND TTYNOTES
(PROG (↑W ↑R)
(INDENT-TO-INSTACK 0)
(PRIN1 (COND ((NULL (CDR SOURCEFILES)) (CAR SOURCEFILES))
(SOURCEFILES)))
(PRINC '| assembled - |)
(PRIN1 FILOC)
(PRINC '| Words|)))
(GCTWA)
WINP)
8. BASE COBARRAY CREADTABLE MSDIR (LIST ()) () () ()))
(DEFUN FASL-START (FILE CONTINUEP)
((LAMBDA (UNFASL-DIR)
(SETQ IMOSAR (EOPEN (MERGEF '(* /←FASL/←) FILE) '(OUT FIXNUM))) ;Open FASL output file
(COND ((NOT CONTINUEP)
(SETQ UFFIL (EOPEN (MERGEF (CONS (LIST '* UNFASL-DIR) ;Open UNFASL file
'(* /←UNFA/←))
FILE)
'(OUT)))
(PUSH UFFIL CMSGFILES)
(LINEL UFFIL 80.)
(AND (SETQ UNFASL-DIR (PROBEF IMOSAR)) (DELETEF UNFASL-DIR))
(AND (SETQ UNFASL-DIR (PROBEF UFFIL)) (DELETEF UNFASL-DIR))
(SETQ UFFIL (LIST UFFIL)) ))
(FASLOUT #,(CAR (PNGET '|*FASL+| 6))) ;First of two word header
(FASLOUT LDFNM) ; is SIXBIT |*FASL+|
(SETQ ALLATOMS (SETQ ENTRYNAMES (SETQ SYMPDL
(SETQ MAINSYMPDL (SETQ CURRENTFNSYMS ())))))
(SETQ BINCT 0)
(FILLARRAY 'NUMBERTABLE '(()) )
(SETQ FILOC (SETQ LITLOC (SETQ *LOC (SETQ ATOMINDEX 0))))
(SETQ ↑W (SETQ ↑R T)))
(COND (MSDIR)
((CADAR FILE))
('*))))
(DEFUN FASL-CLOSEOUT (TARGETFILE SOURCEFILES UNFASLNAM)
(AND UNFASLNAM (SETQ UNFASLNAM (MERGEF '(* UNFASL) UNFASLNAM)))
(BUFFERBIN 17 0 ()) ;End of file flag
(AND (NOT SOURCEFILES)
(SETQ TARGETFILE (MERGEF '(/←FASL←/ OUTPUT) TARGETFILE)))
(FASL-RENAMEF IMOSAR TARGETFILE)
(SETQ IMOSAR ()) ;Close binary output file
(COND (SOURCEFILES
(AND UNFASLCOMMENTS
(NOTE-IN-UNFASL '|TOTAL = | FILOC '| WORDS|)) ;Close UNFASL file
(COND ((NULL UNFASLNAM)) ;If kill-flag permits, and
('T (FASL-RENAMEF (CAR UFFIL) UNFASLNAM)
(AND (NULL UNFASLSIGNIF)
(PROBEF (CAR UFFIL))
(DELETEF (CAR UFFIL)))
(SETQ UFFIL () ))))
('T (DELETEF TARGETFILE) ;Kill FASL file, if
(COND ((AND UFFIL UNFASLNAM) ; wrong or INSIGNIF
(FASL-RENAMEF (CAR UFFIL) UNFASLNAM)
(SETQ UFFIL () )))
(MOBYSYMPOP MAINSYMPDL)
(REMPROPL 'SYM CURRENTFNSYMS)))
(COND ((AND #(SAILP) (NOT UNFASLCOMMENTS) (PROBEF UNFASLNAM))
(DELETEF UNFASLNAM)))
(REMPROPL 'ENTRY ENTRYNAMES) ;Flush no-longer-needed props
(REMPROPL 'ARGSINFO ENTRYNAMES)
(REMPROPL 'ATOMINDEX ALLATOMS)
(FILLARRAY 'BSAR '(()) )
(FILLARRAY 'NUMBERTABLE '(()) )
(SETQ SYMPDL (SETQ MAINSYMPDL (SETQ CURRENTFNSYMS () )))
(SETQ ALLATOMS (SETQ ENTRYNAMES () )))
(DEFUN FASL-RENAMEF (X Y)
(AND (NOT #(ITSP)) (NOT #(DEC20P)) (PROBEF Y) (DELETEF Y))
(RENAMEF X Y))
(DEFUN UNFASL-MSG (FILE)
#(LET ((↑W 'T) (↑R 'T) (TERPRI 'T) (OUTFILES UFFIL))
(TERPRI)
(PRINC '|'/(THIS IS THE UNFASL FOR |) ;BARF OUT HEADER
(PRINT-LINEND FILE 'T) ; FOR UNFASL FILE
(PRINC '|'(ASSEMBLED BY FASLAP //|)
(PRINT-LINEND FASLVERNO () )))
(DEFUN NOTE-IN-UNFASL (MSG W FL)
#(LET ((↑R 'T) (↑W 'T) (TERPRI 'T) (OUTFILES UFFIL)
(BASE 10.) (*NOPOINT () ))
(TERPRI) ;TERPRI before comment
(PRINC '| (COMMENT **FASL** |)
(PRINC MSG)
(AND W (PRINC '| |) (PRIN1 W))
(AND FL (PRINC FL))
(PRINC '|) |)
(AND ↑R (SETQ UNFASLSIGNIF ↑R))))
ββββ